perm filename BASIC.LSP[206,JMC] blob sn#367503 filedate 1978-07-10 generic text, type T, neo UTF8

(DEFPROP BASICFNS
 (BASICFNS ORLIS
	   ANDLIS
	   MAPCAR2
	   MAPCHOOSE
	   MAPAPP
	   PRUP
	   LISTSUBT
	   LISTSUBTA
	   CONTAINED
	   DELETE
	   PICKOUT
	   PICKOUTA
	   NTH 
	   SUBLIS 
)
VALUE)

(DEFPROP ORLIS
 (LAMBDA(PRED U)
  (AND (NOT (NULL U)) (OR (PRED (CAR U)) (ORLIS PRED (CDR U)))))
EXPR)

(DEFPROP ANDLIS
 (LAMBDA(PRED U)
  (OR (NULL U) (AND (PRED (CAR U)) (ANDLIS PRED (CDR U)))))
EXPR)

(DEFPROP MAPCAR2
 (LAMBDA(FN U V)
  (COND	((NULL U) NIL)
	(T
	 (CONS (FN (CAR U) (CAR V)) (MAPCAR2 FN (CDR U) (CDR V))))))
EXPR)

(DEFPROP MAPCHOOSE
 (LAMBDA(PRED FN U)
  (COND	((NULL U) NIL)
	((PRED (CAR U))
	 (CONS (FN (CAR U)) (MAPCHOOSE PRED FN (CDR U))))
	(T (MAPCHOOSE PRED FN (CDR U)))))
EXPR)

(DEFPROP MAPAPP
 (LAMBDA(FN U)
  (COND	((NULL U) NIL)
	(T (APPEND (FN (CAR U)) (MAPAPP FN (CDR U))))))
EXPR)

(DEFPROP PRUP
 (LAMBDA(U V)
  (COND	((NULL U)
	 (COND ((NULL V) NIL) (T (ERROR (QUOTE (V LONGER - PRUP))))))
	((NULL V) (ERROR (QUOTE (U LONGER - PRUP))))
	(T (CONS (CONS (CAR U) (CAR V)) (PRUP (CDR U) (CDR V))))))
EXPR)

(DEFPROP LISTSUBT
 (LAMBDA (U V) (LISTSUBTA U (DIFFERENCE (LENGTH U) (LENGTH V)) NIL))
EXPR)

(DEFPROP LISTSUBTA
 (LAMBDA(U N Z)
  (COND	((EQUAL N 0) Z)
	(T (LISTSUBTA (CDR U) (SUB1 N) (CONS (CAR U) Z)))))
EXPR)

(DEFPROP CONTAINED
 (LAMBDA(U V)
  (OR (NULL U) (AND (MEMBER (CAR U) V) (CONTAINED (CDR U) V))))
EXPR)

(DEFPROP DELETE
 (LAMBDA(X U)
  (COND	((NULL U) NIL)
	((EQUAL X (CAR U)) (CDR U))
	(T (CONS (CAR U) (DELETE X (CDR U))))))
EXPR)

(DEFPROP PICKOUT
 (LAMBDA (PRED U) (PICKOUTA PRED U NIL NIL))
EXPR)

(DEFPROP PICKOUTA
 (LAMBDA(PRED U X Y)
  (COND	((NULL U) (CONS X Y))
	((PRED (CAR U)) (PICKOUTA PRED (CDR U) (CONS (CAR U) X) Y))
	(T (PICKOUTA PRED (CDR U) X (CONS (CAR U) Y)))))
EXPR)

(DEFPROP SUBLIS 
 (LAMBDA (S X) (COND ((ATOM X) ((LAMBDA (Z) (COND ((NULL Z) X) (T (CDR Z))))
			(ASSOC X S)))
	(T ((LAMBDA (U V) (COND ((AND (EQ U (CAR X)) (EQ V (CDR X))) X)
			(T (CONS U V))))
		(SUBLIS S (CAR X)) (SUBLIS S (CDR X))))))
EXPR)

(DEFPROP NTH 
 (LAMBDA (U N) (COND ((EQUAL N 1)(CAR U)) (T (NTH (CDR U) (SUB1 N)))))
EXPR)